TTE Modeling Results

Results path: results/2024-11-04-16-04-42.547127

Trial speed

Code

p = list()

for( cur_scenario in unique(outcome_fig_noninformative$scenario)){
  cur_plot <- outcome_fig_noninformative |>
    filter(scenario == cur_scenario) |>
    ggplot(
      aes(x = dropout, y=last_cohort_time, fill = model)
    ) + 
    # geom_boxplot( alpha = 0.5) + 
    stat_histinterval(
      position = position_dodgejust(width = 0.8), 
      width = 0.8, 
      breaks = 1:max(outcome_fig_noninformative$last_cohort_time)
    ) +
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p) == 0, "# Cohorts", "")) + ylim(c(1,max(outcome_fig_noninformative$last_cohort_time))) +
    labs(fill='Method:') +
    xlab("Dropout over 3 cycles")
  
  p <- c(p, list(cur_plot))
}
plot_ncohorts <- ggarrange(plotlist = p, common.legend = T, ncol = 3) 
plot_ncohorts_ann <- annotate_figure(plot_ncohorts, top = text_grob("Number of cohorts enrolled in trial", 
                                          color = "black", face = "bold", size = 14))


plot_ncohorts_ann

Enrolled patients

Code

p = list()

for( cur_scenario in unique(outcome_fig_noninformative$scenario)){
  
  cur_data <- outcome_fig_noninformative |>
    filter(scenario == cur_scenario) 
  
  cur_plot <- cur_data |>
    ggplot(
      aes(x = dropout, y=num_patients_start, fill = model)
    ) + 
    # geom_boxplot( alpha = 0.5) + 
    stat_histinterval(
      position = position_dodgejust(width = 0.8), 
      width = 0.8, 
      breaks = 3*(1:max(outcome_fig_noninformative$last_cohort_time))
    ) +
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p) == 0, "# Patients", "")) + ylim(c(1,max(outcome_fig_noninformative$num_patients_start))) +
    labs(fill='Method:') + 
    xlab("Dropout over 3 cycles")
  
  cur_data_summary <- cur_data |> 
    group_by(dropout, model) |> 
    summarize(num_patients_start = rvar(num_patients_start), .groups = "keep") |>
    mutate(
      num_patients_start_mean = mean(num_patients_start),
      num_patients_start_mean_mcse = mcse_mean(num_patients_start)
    )
  
  cat(paste0("\n### ", cur_scenario, "\n\n"))

  if (interactive()) {
    print(cur_data_summary |> kable())
  } else {
    cat(sep = "\n", knitr::knit_child(quiet = TRUE, text = c(
      "```{r}",
      "#| echo: false",
      "cur_data_summary |> kable(digits = 1)",
      "```"
    )))
  }
  
  p <- c(p, list(cur_plot))
}

constant

dropout	model	num_patients_start	num_patients_start_mean	num_patients_start_mean_mcse
0%	B1	23 ± 3.1	23.1	0.1
0%	B3	16 ± 5.0	15.5	0.2
0%	TCO	22 ± 3.5	21.9	0.1
0%	TCU	16 ± 4.5	16.2	0.2
33%	B1	26 ± 3.6	26.3	0.1
33%	B3	20 ± 7.5	20.4	0.2
33%	TCO	24 ± 4.2	24.4	0.1
33%	TCU	18 ± 5.4	18.1	0.2
55%	B1	29 ± 4.2	28.5	0.1
55%	B3	25 ± 10.7	24.9	0.3
55%	TCO	26 ± 4.5	26.0	0.1
55%	TCU	20 ± 6.0	19.6	0.2

increasing

dropout	model	num_patients_start	num_patients_start_mean	num_patients_start_mean_mcse
0%	B1	25 ± 2.8	24.8	0.1
0%	B3	15 ± 5.0	15.1	0.2
0%	TCO	22 ± 3.8	22.3	0.1
0%	TCU	16 ± 4.8	15.9	0.2
33%	B1	27 ± 3.7	27.4	0.1
33%	B3	21 ± 7.7	20.6	0.2
33%	TCO	25 ± 4.6	24.7	0.2
33%	TCU	18 ± 5.6	17.9	0.2
55%	B1	30 ± 4.5	30.4	0.1
55%	B3	26 ± 10.9	26.2	0.3
55%	TCO	27 ± 5.0	26.7	0.2
55%	TCU	20 ± 6.3	19.9	0.2

decreasing

dropout	model	num_patients_start	num_patients_start_mean	num_patients_start_mean_mcse
0%	B1	22 ± 2.7	21.9	0.1
0%	B3	15 ± 5.0	15.4	0.2
0%	TCO	22 ± 3.3	21.8	0.1
0%	TCU	16 ± 4.6	16.0	0.2
33%	B1	25 ± 3.5	25.1	0.1
33%	B3	19 ± 7.7	19.5	0.2
33%	TCO	24 ± 4.2	24.1	0.1
33%	TCU	18 ± 5.5	18.1	0.2
55%	B1	27 ± 4.1	27.1	0.1
55%	B3	23 ± 10.7	22.9	0.4
55%	TCO	26 ± 4.3	25.7	0.1
55%	TCU	20 ± 5.9	19.7	0.2

Code

plot_npatients <- ggarrange(plotlist = p, common.legend = T, ncol = 3) 
plot_npatients_ann <- annotate_figure(plot_npatients, top = text_grob("Number of patients enrolled in trial", 
                                                                  color = "black", face = "bold", size = 14))


ggsave(file.path(path.export, "npatients.pdf"), plot = plot_npatients_ann , width=20*2.5, height=10*1.2, units="cm")

Plot

Code

plot_npatients_ann

Stopping reasons & MTD allocation, Cycle 1

Code

preprocess_data_MTD_cycle1 <- function(x, cur_scenario) {
  cur_data <- x |>
    filter(scenario == cur_scenario)
  
  cur_data |> 
    count(model, dropout, stop_reason_cycle1) |>    
    group_by(model, dropout) |>
    mutate(percent = round(prop.table(n) * 100)) |>
    mutate(percent = ifelse(percent > 0, paste0(percent, "%"), ""))
}

p_cycle1_MTDs = list()
for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  cur_plot <- preprocess_data_MTD_cycle1(outcome_fig_noninformative, cur_scenario) |>
    ggplot(aes(x = dropout, y = n, fill = stop_reason_cycle1)) + 
    geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p_cycle1_MTDs) == 0, "Relative frequencies", "")) +
    xlab("Dropout over 3 cycles") + 
    scale_fill_manual(values = dosing_colors, drop = FALSE) +
    facet_grid(. ~ factor(model), scales = "free", space = "free_x")+
    labs(fill='Stopping reason') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1)) + 
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  
  p_cycle1_MTDs <- c(p_cycle1_MTDs, list(cur_plot))
}
plot_cycle1_MTDs <- ggarrange( plotlist = p_cycle1_MTDs, common.legend = T, ncol = 3)
plot_cycle1_MTDs_ann <- plot_cycle1_MTDs |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: relative frequencies, cycle-1 MTDs",
      color = "black", face = "bold", size = 14
    )
  )

plot_cycle1_MTDs_ann

Code

ggsave(file.path(path.export, "MTD_cycle1_frequencies.pdf"), plot = plot_cycle1_MTDs_ann , width=20*2.5, height=10*1.2, units="cm")

Stopping reasons & MTD allocation, Cumulative

Code

preprocess_data_MTD_cumulative <- function(x, cur_scenario) {
  cur_data <- x |>
    filter(scenario == cur_scenario)
  
  cur_data |> 
    count(model, dropout, stop_reason_cumulative) |>    
    group_by(model, dropout) |>
    mutate(percent = round(prop.table(n) * 100)) |>
    mutate(percent = ifelse(percent > 0, paste0(percent, "%"), ""))
}

p_cumulative_MTDs = list()

n_sims <- unique((outcome_fig_noninformative |>
    count(model, dropout, scenario))$n)

for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  cur_plot <- preprocess_data_MTD_cumulative(outcome_fig_noninformative, cur_scenario) |>
    ggplot(aes(x = dropout, y = n, fill = stop_reason_cumulative)) + 
    geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p_cumulative_MTDs) == 0, "Relative frequencies", "")) +
    xlab("Dropout over 3 cycles") + 
    scale_fill_manual(values = dosing_colors, drop = FALSE) +
    facet_grid(. ~ factor(model), scales = "free", space = "free_x")+
    labs(fill='Stopping reason') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1)) + 
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  
  p_cumulative_MTDs <- c(p_cumulative_MTDs, list(cur_plot))
  
  cur_data_summary <- outcome_fig_noninformative |>
    filter(scenario == cur_scenario) |>
    group_by(dropout, model) |>
    summarize(
      rvar_MTD_target = rvar(MTD_is_target_cumulative * 1.0), 
      rvar_MTD_overdose = rvar(MTD_is_overdose_cumulative * 1.0), 
      rvar_MTD_underdose = rvar(MTD_is_underdose_cumulative * 1.0), 
      rvar_stopped = rvar(stopped_due_to_toxicity * 1.0),
      .groups = "keep"
    ) |>
    mutate(
      mean_MTD_target = mean(rvar_MTD_target),
      mcse_MTD_target = mcse_mean(rvar_MTD_target),
      mean_MTD_overdose = mean(rvar_MTD_overdose),
      mcse_MTD_overdose = mcse_mean(rvar_MTD_overdose),
      mean_MTD_underdose = mean(rvar_MTD_underdose),
      mcse_MTD_underdose = mcse_mean(rvar_MTD_underdose),
      mean_stopped = mean(rvar_stopped),
      mcse_stopped = mcse_mean(rvar_stopped)
    )
  

  cat(paste0("\n### ", cur_scenario, "\n\n"))

  if (interactive()) {
    print(cur_data_summary |> kable())
  } else {
    cat(sep = "\n", knitr::knit_child(quiet = TRUE, text = c(
      "```{r}",
      "#| echo: false",
      "cur_data_summary |> kable(digits = 2)",
      "```"
    )))
  }
}

constant

dropout	model	rvar_MTD_target	rvar_MTD_overdose	rvar_MTD_underdose	rvar_stopped	mean_MTD_target	mcse_MTD_target	mean_MTD_overdose	mcse_MTD_overdose	mean_MTD_underdose	mcse_MTD_underdose	mean_stopped	mcse_stopped
0%	B1	0.20 ± 0.40	0.799 ± 0.401	0.000 ± 0.000	0.000 ± 0.000	0.20	0.01	0.80	0.01	0.00	NA	0.00	NA
0%	B3	0.87 ± 0.33	0.001 ± 0.032	0.006 ± 0.077	0.119 ± 0.324	0.87	0.01	0.00	0.00	0.01	0	0.12	0.01
0%	TCO	0.11 ± 0.32	0.883 ± 0.322	0.000 ± 0.000	0.003 ± 0.055	0.11	0.01	0.88	0.01	0.00	NA	0.00	0.00
0%	TCU	0.89 ± 0.31	0.012 ± 0.109	0.000 ± 0.000	0.096 ± 0.295	0.89	0.01	0.01	0.00	0.00	NA	0.10	0.01
33%	B1	0.26 ± 0.44	0.741 ± 0.438	0.000 ± 0.000	0.000 ± 0.000	0.26	0.01	0.74	0.01	0.00	NA	0.00	NA
33%	B3	0.83 ± 0.37	0.001 ± 0.032	0.000 ± 0.000	0.168 ± 0.374	0.83	0.01	0.00	0.00	0.00	NA	0.17	0.01
33%	TCO	0.13 ± 0.33	0.868 ± 0.339	0.000 ± 0.000	0.004 ± 0.063	0.13	0.01	0.87	0.01	0.00	NA	0.00	0.00
33%	TCU	0.89 ± 0.31	0.006 ± 0.077	0.001 ± 0.032	0.100 ± 0.300	0.89	0.01	0.01	0.00	0.00	0	0.10	0.01
55%	B1	0.31 ± 0.46	0.688 ± 0.464	0.000 ± 0.000	0.000 ± 0.000	0.31	0.01	0.69	0.01	0.00	NA	0.00	NA
55%	B3	0.72 ± 0.45	0.000 ± 0.000	0.000 ± 0.000	0.279 ± 0.449	0.72	0.01	0.00	NA	0.00	NA	0.28	0.01
55%	TCO	0.18 ± 0.38	0.821 ± 0.384	0.000 ± 0.000	0.003 ± 0.055	0.18	0.01	0.82	0.01	0.00	NA	0.00	0.00
55%	TCU	0.87 ± 0.34	0.006 ± 0.077	0.001 ± 0.032	0.124 ± 0.330	0.87	0.01	0.01	0.00	0.00	0	0.12	0.01

increasing

dropout	model	rvar_MTD_target	rvar_MTD_overdose	rvar_MTD_underdose	rvar_stopped	mean_MTD_target	mcse_MTD_target	mean_MTD_overdose	mcse_MTD_overdose	mean_MTD_underdose	mcse_MTD_underdose	mean_stopped	mcse_stopped
0%	B1	0.011 ± 0.10	0.989 ± 0.104	0.000 ± 0.000	0.000 ± 0.000	0.01	0.00	0.99	0.00	0	NA	0.00	NA
0%	B3	0.871 ± 0.34	0.002 ± 0.045	0.002 ± 0.045	0.125 ± 0.331	0.87	0.01	0.00	0.00	0	0	0.12	0.01
0%	TCO	0.036 ± 0.19	0.956 ± 0.205	0.000 ± 0.000	0.008 ± 0.089	0.04	0.01	0.96	0.01	0	NA	0.01	0.00
0%	TCU	0.839 ± 0.37	0.015 ± 0.122	0.000 ± 0.000	0.146 ± 0.353	0.84	0.01	0.01	0.00	0	NA	0.15	0.01
33%	B1	0.020 ± 0.14	0.980 ± 0.140	0.000 ± 0.000	0.000 ± 0.000	0.02	0.00	0.98	0.00	0	NA	0.00	NA
33%	B3	0.836 ± 0.37	0.002 ± 0.045	0.000 ± 0.000	0.162 ± 0.369	0.84	0.01	0.00	0.00	0	NA	0.16	0.01
33%	TCO	0.042 ± 0.20	0.941 ± 0.236	0.000 ± 0.000	0.017 ± 0.129	0.04	0.01	0.94	0.01	0	NA	0.02	0.00
33%	TCU	0.832 ± 0.37	0.014 ± 0.118	0.000 ± 0.000	0.154 ± 0.361	0.83	0.01	0.01	0.00	0	NA	0.15	0.01
55%	B1	0.031 ± 0.17	0.969 ± 0.173	0.000 ± 0.000	0.000 ± 0.000	0.03	0.01	0.97	0.01	0	NA	0.00	NA
55%	B3	0.785 ± 0.41	0.000 ± 0.000	0.000 ± 0.000	0.215 ± 0.411	0.78	0.01	0.00	NA	0	NA	0.22	0.01
55%	TCO	0.037 ± 0.19	0.941 ± 0.236	0.000 ± 0.000	0.022 ± 0.147	0.04	0.01	0.94	0.01	0	NA	0.02	0.00
55%	TCU	0.825 ± 0.38	0.012 ± 0.109	0.000 ± 0.000	0.163 ± 0.370	0.82	0.01	0.01	0.00	0	NA	0.16	0.01

decreasing

dropout	model	rvar_MTD_target	rvar_MTD_overdose	rvar_MTD_underdose	rvar_stopped	mean_MTD_target	mcse_MTD_target	mean_MTD_overdose	mcse_MTD_overdose	mean_MTD_underdose	mcse_MTD_underdose	mean_stopped	mcse_stopped
0%	B1	0.50 ± 0.50	0.500 ± 0.500	0.000 ± 0.000	0.000 ± 0.00	0.50	0.02	0.50	0.02	0.00	NA	0.00	NA
0%	B3	0.87 ± 0.34	0.006 ± 0.077	0.007 ± 0.083	0.119 ± 0.32	0.87	0.01	0.01	0.00	0.01	0	0.12	0.01
0%	TCO	0.21 ± 0.41	0.790 ± 0.408	0.000 ± 0.000	0.000 ± 0.00	0.21	0.01	0.79	0.01	0.00	NA	0.00	NA
0%	TCU	0.92 ± 0.27	0.008 ± 0.089	0.000 ± 0.000	0.074 ± 0.26	0.92	0.01	0.01	0.00	0.00	NA	0.07	0.01
33%	B1	0.55 ± 0.50	0.446 ± 0.497	0.000 ± 0.000	0.000 ± 0.00	0.55	0.02	0.45	0.02	0.00	NA	0.00	NA
33%	B3	0.79 ± 0.41	0.000 ± 0.000	0.002 ± 0.045	0.211 ± 0.41	0.79	0.01	0.00	NA	0.00	0	0.21	0.01
33%	TCO	0.25 ± 0.44	0.746 ± 0.436	0.000 ± 0.000	0.000 ± 0.00	0.25	0.01	0.75	0.01	0.00	NA	0.00	NA
33%	TCU	0.92 ± 0.27	0.001 ± 0.032	0.002 ± 0.045	0.079 ± 0.27	0.92	0.01	0.00	0.00	0.00	0	0.08	0.01
55%	B1	0.61 ± 0.49	0.387 ± 0.487	0.000 ± 0.000	0.000 ± 0.00	0.61	0.01	0.39	0.01	0.00	NA	0.00	NA
55%	B3	0.61 ± 0.49	0.000 ± 0.000	0.000 ± 0.000	0.393 ± 0.49	0.61	0.02	0.00	NA	0.00	NA	0.39	0.02
55%	TCO	0.31 ± 0.46	0.689 ± 0.463	0.000 ± 0.000	0.000 ± 0.00	0.31	0.01	0.69	0.01	0.00	NA	0.00	NA
55%	TCU	0.90 ± 0.30	0.004 ± 0.063	0.000 ± 0.000	0.098 ± 0.30	0.90	0.01	0.00	0.00	0.00	NA	0.10	0.01

Plot

Code

plot_cumulative_MTDs <- ggarrange( plotlist = p_cumulative_MTDs, common.legend = T, ncol = 3)
plot_cumulative_MTDs_ann <- plot_cumulative_MTDs |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: relative frequencies, cumulative MTDs",
      color = "black", face = "bold", size = 14
    )
  )

plot_cumulative_MTDs_ann

Code

ggsave(file.path(path.export, "MTD_cumulative_frequencies.png"), plot = plot_cumulative_MTDs_ann , width=20*2.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "MTD_cumulative_frequencies.pdf"), plot = plot_cumulative_MTDs_ann , width=20*2.5, height=10*1.2, units="cm")

Joint figure

Code

plotlist_both <- c(
    p_cycle1_MTDs |> map(\(x){x + xlab("")}), 
    p_cumulative_MTDs |> map(\(x){x + ggtitle("")})
  )

plotlist_both[[1]] <- plotlist_both[[1]] + ylab("Relative frequencies, cycle-1")
plotlist_both[[4]] <- plotlist_both[[4]] + ylab("Relative frequencies, cumulative")
plot_both_MTDs <- ggarrange(
  plotlist = plotlist_both,
  common.legend = T, ncol = 3, nrow = 2
)
plot_both_MTDs_ann <- plot_both_MTDs |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: relative frequencies, cycle-1 and cumulative MTDs",
      color = "black", face = "bold", size = 14
    )
  )


ggsave(file.path(path.export, "MTD_frequencies.pdf"), plot = plot_both_MTDs_ann , width=20*2.5, height=10*2, units="cm")
ggsave(file.path(path.export, "MTD_frequencies.png"), plot = plot_both_MTDs_ann , width=20*2.5, height=10*2, units="cm")


plot_both_MTDs_ann

Patient allocation, Cycle 1

Code

p_cycle1_patients = list()
for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  res <- outcome_fig_noninformative |>
    select(
      scenario, model, dropout, 
      num_patients_cycle1, 
      num_patients_overdose_cycle1,
      num_patients_target_cycle1,
      num_patients_underdose_cycle1
    ) |> 
    group_by(scenario, model, dropout) |>
    summarize(
      prob_patients_overdose_cycle1  = sum(num_patients_overdose_cycle1)  / sum(num_patients_cycle1),
      prob_patients_target_cycle1    = sum(num_patients_target_cycle1)    / sum(num_patients_cycle1),
      prob_patients_underdose_cycle1 = sum(num_patients_underdose_cycle1) / sum(num_patients_cycle1)
    ) |>
    filter(scenario == cur_scenario)
  
  res_long <- res |> 
    pivot_longer(
      cols = starts_with("prob_patients"), 
      names_transform = function(name) {
        name |>
          str_replace_all("prob_patients_", "") |> 
          str_replace_all("_cycle1", "")
      }
    ) |> 
    mutate(name = factor(name)) |>
    mutate(percent = ifelse(round(value * 100) > 0, paste0(round(value * 100), "%"), ""))
  
  cur_plot <- res_long |>
    ggplot(aes(x = dropout, y = value, fill = name)) + 
    geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
    # stat_slab(
    #   position = position_dodgejust(width = 0.8), 
    #   width = 0.8, 
    # ) +
    #geom_boxplot( alpha = 0.5) +
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p_cycle1_patients) == 0, "Relative frequencies", "")) +
    xlab("Dropout over 3 cycles") + 
    scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
    facet_grid(. ~ factor(model), scales = "free", space = "free_x")+
    labs(fill='Interval') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1)) +
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  
  p_cycle1_patients <- c(p_cycle1_patients, list(cur_plot))
}

`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.

Code

plot_cycle1_patients <- ggarrange( plotlist = p_cycle1_patients, common.legend = T, ncol = 3)
plot_cycle1_patients_ann <- plot_cycle1_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients in cycle 1",
      color = "black", face = "bold", size = 14
    )
  )

ggsave(file.path(path.export, "patients_cycle1_frequencies.png"), plot = plot_cycle1_patients_ann , width=20*2.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "patients_cycle1_frequencies.pdf"), plot = plot_cycle1_patients_ann , width=20*2.5, height=10*1.2, units="cm")

plot_cycle1_patients_ann

Patient allocation, Cumulative

Code

p_cumulative_patients = list()
for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  res <- outcome_fig_noninformative |>
    select(
      scenario, model, dropout, 
      num_patients_cumulative, 
      num_patients_overdose_cumulative,
      num_patients_target_cumulative,
      num_patients_underdose_cumulative
    ) |>
    group_by(scenario, model, dropout) |>
    summarize(
      prob_patients_overdose_cumulative  = sum(num_patients_overdose_cumulative)  / sum(num_patients_cumulative),
      prob_patients_target_cumulative    = sum(num_patients_target_cumulative)    / sum(num_patients_cumulative),
      prob_patients_underdose_cumulative = sum(num_patients_underdose_cumulative) / sum(num_patients_cumulative)
    ) |>
    filter(scenario == cur_scenario)
  
  res_long <- res |> 
    pivot_longer(
      cols = starts_with("prob_patients"), 
      names_transform = function(name) {
        name |>
          str_replace_all("prob_patients_", "") |> 
          str_replace_all("_cumulative", "")
      }
    ) |>     
    mutate(name = factor(name)) |>
    mutate(percent = ifelse(round(value * 100) > 0, paste0(round(value * 100), "%"), ""))
  
  cur_plot <- res_long |>
    ggplot(aes(x = dropout, y = value, fill = name)) + 
    geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
    # stat_slab(
    #   position = position_dodgejust(width = 0.8), 
    #   width = 0.8, 
    # ) +
    # geom_boxplot( alpha = 0.5) +
    ggtitle(paste(cur_scenario, "toxicity")) + 
    ylab(ifelse(length(p_cumulative_patients) == 0, "Relative frequencies", "")) +
    xlab("Dropout over 3 cycles") + 
    scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
    facet_grid(. ~ factor(model), scales = "free", space = "free_x")+
    labs(fill='Interval') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1)) +
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  
  p_cumulative_patients <- c(p_cumulative_patients, list(cur_plot))
}

`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.
`summarise()` has grouped output by 'scenario', 'model'. You can override using
the `.groups` argument.

Code

plot_cumulative_patients <- ggarrange( plotlist = p_cumulative_patients, common.legend = T, ncol = 3)
plot_cumulative_patients_ann <- plot_cumulative_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients over 3 cycles (cumulative)",
      color = "black", face = "bold", size = 14
    )
  )


ggsave(file.path(path.export, "patients_cumulative_frequencies.png"), plot = plot_cumulative_patients_ann , width=20*2.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "patients_cumulative_frequencies.pdf"), plot = plot_cumulative_patients_ann , width=20*2.5, height=10*1.2, units="cm")

ggsave(file.path(path.export, "patient_allocation_main.png"), plot = p_cumulative_patients[[1]] + ggtitle("Probability of dosing patients over 3 cycles,\n(cumulative) constant toxicity"), width=15, height=12, units="cm")

ggsave(file.path(path.export, "patient_allocation_main.pdf"), plot = p_cumulative_patients[[1]] + ggtitle("Probability of dosing patients over 3 cycles,\n(cumulative) constant toxicity"), width=15, height=12, units="cm")



plot_cumulative_patients_ann

Joint figure

Code

plotlist_both <- c(
    p_cycle1_patients |> map(\(x){x + xlab("")}), 
    p_cumulative_patients |> map(\(x){x + ggtitle("")})
  )

plotlist_both[[1]] <- plotlist_both[[1]] + ylab("Relative frequencies, cycle-1")
plotlist_both[[4]] <- plotlist_both[[4]] + ylab("Relative frequencies, cumulative")
plot_both_patients <- ggarrange(
  plotlist = plotlist_both,
  common.legend = T, ncol = 3, nrow = 2
)
plot_both_patients_ann <- plot_both_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients",
      color = "black", face = "bold", size = 14
    )
  )

ggsave(file.path(path.export, "patient_frequencies.pdf"), plot = plot_both_patients_ann , width=20*2.5, height=10*2, units="cm")
ggsave(file.path(path.export, "patient_frequencies.png"), plot = plot_both_patients_ann , width=20*2.5, height=10*2, units="cm")

plot_both_patients_ann

Trial length

Code

p_trial_length_days = list()

res <- outcome_fig_noninformative |>
  select(
    scenario, model, dropout, 
    start_to_last_patient_cens_event_dt
  ) |>
  mutate(length_years = time_length(start_to_last_patient_cens_event_dt, "years"))

for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  cur_plot <- res |> filter(scenario == cur_scenario) |>
    ggplot(aes(x = dropout, y = length_years)) + 
    ggtitle(paste(cur_scenario, "toxicity")) + 
    # stat_slab(
    #   position = position_dodgejust(width = 0.8), 
    #   width = 0.8, 
    # ) +
    geom_boxplot( alpha = 0.5) +
    ylab(ifelse(length(p_trial_length_days) == 0, "Years", "")) +
    scale_y_continuous(breaks=c(0, 2, 4, 6, 8), limits=c(0, 9)) + 
    xlab("Dropout over 3 cycles") + 
    # scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
    facet_grid(. ~ model, scales = "free", space = "free_x")+
    labs(fill='Interval') +
    theme(axis.text.x = element_text(angle = 45, size = 8, hjust = 1))
  
  cur_data_summary <- res |> 
    filter(scenario == cur_scenario) |>
    group_by(dropout, model) |> 
    summarize(length_years = rvar(length_years), .groups = "keep") |>
    mutate(
      length_years_mean = mean(length_years),
      length_years_mean_mcse = mcse_mean(length_years)
    )
  
  cat(paste0("\n### ", cur_scenario, "\n\n"))

  if (interactive()) {
    print(cur_data_summary |> kable())
  } else {
    cat(sep = "\n", knitr::knit_child(quiet = TRUE, text = c(
      "```{r}",
      "#| echo: false",
      "cur_data_summary |> kable(digits = 1)",
      "```"
    )))
  }
  
  p_trial_length_days <- c(p_trial_length_days, list(cur_plot))
}

constant

dropout	model	length_years	length_years_mean	length_years_mean_mcse
0%	B1	1.7 ± 0.25	1.7	0
0%	B3	2.2 ± 0.74	2.2	0
0%	TCO	1.7 ± 0.26	1.7	0
0%	TCU	1.3 ± 0.32	1.3	0
33%	B1	1.9 ± 0.27	1.9	0
33%	B3	2.8 ± 1.06	2.8	0
33%	TCO	1.8 ± 0.31	1.8	0
33%	TCU	1.4 ± 0.38	1.4	0
55%	B1	2.0 ± 0.30	2.0	0
55%	B3	3.3 ± 1.41	3.3	0
55%	TCO	1.8 ± 0.33	1.8	0
55%	TCU	1.5 ± 0.40	1.5	0

increasing

dropout	model	length_years	length_years_mean	length_years_mean_mcse
0%	B1	1.8 ± 0.24	1.8	0
0%	B3	2.2 ± 0.73	2.2	0
0%	TCO	1.7 ± 0.28	1.7	0
0%	TCU	1.3 ± 0.34	1.3	0
33%	B1	2.0 ± 0.28	2.0	0
33%	B3	2.8 ± 1.06	2.8	0
33%	TCO	1.8 ± 0.33	1.8	0
33%	TCU	1.4 ± 0.39	1.4	0
55%	B1	2.1 ± 0.32	2.1	0
55%	B3	3.4 ± 1.41	3.4	0
55%	TCO	1.9 ± 0.35	1.9	0
55%	TCU	1.5 ± 0.42	1.5	0

decreasing

dropout	model	length_years	length_years_mean	length_years_mean_mcse
0%	B1	1.7 ± 0.22	1.7	0
0%	B3	2.2 ± 0.73	2.2	0
0%	TCO	1.7 ± 0.26	1.7	0
0%	TCU	1.3 ± 0.33	1.3	0
33%	B1	1.8 ± 0.28	1.8	0
33%	B3	2.7 ± 1.08	2.7	0
33%	TCO	1.8 ± 0.31	1.8	0
33%	TCU	1.4 ± 0.38	1.4	0
55%	B1	1.9 ± 0.31	1.9	0
55%	B3	3.0 ± 1.44	3.0	0
55%	TCO	1.8 ± 0.32	1.8	0
55%	TCU	1.5 ± 0.40	1.5	0

Code

plot_trial_length_days <- ggarrange( plotlist = p_trial_length_days[c(2,3)], common.legend = T, ncol = 2)
plot_trial_length_days_ann <- plot_trial_length_days |>
  annotate_figure(
    top = text_grob(
      "Absolute trial length",
      color = "black", face = "bold", size = 14
    )
  )

trial_length_const <- p_trial_length_days[[1]] + ggtitle("Absolute trial length, constant toxicity") 

ggsave(file.path(path.export, "trial_lengths_all.pdf"), plot = plot_trial_length_days_ann, width=10*2.2, height=14, units="cm")

ggsave(file.path(path.export, "trial_lengths.png"), plot = trial_length_const, width=10, height=14, units="cm")
ggsave(file.path(path.export, "trial_lengths.pdf"), plot = trial_length_const, width=10, height=14, units="cm")

Constant scenario plot

Code

trial_length_const

Increasing / decreasing scenario plot

Code

plot_trial_length_days_ann

MTD dose distribution

Code

p = list()

for(cur_scenario in unique(outcome_fig_noninformative$scenario)) {
  cur_plot <- outcome_fig_noninformative |>
    filter(scenario == cur_scenario) |>
    ggplot(aes(x = dropout, y = MTD_dose, fill = model)) +
    # geom_boxplot(alpha = 0.5) + 
    scale_y_continuous(trans = 'log10', breaks = sort(unique(outcome_fig_noninformative$MTD_dose))) +
    stat_histinterval(
      position = position_dodgejust(width = 0.8),
      width = 0.8
    ) +
    # geom_hline(yintercept = true_critical_dose[i],  color = "black", size=1) +
    # # geom_hline(yintercept = 5.03,  color = "black", size=1,linetype = "dashed") + 
    ylab("MTD") +xlab("Historical sample size (n_h)")+
    theme(axis.text.x = element_text(size = 9))  +
    ggtitle(paste(cur_scenario, "toxicity"))+
    labs(fill='Model:')
  
  p <- c(p, list(cur_plot))
}
plot_MTDs <- ggarrange(plotlist = p, common.legend = T, ncol = 3) 

Warning: Removed 896 rows containing missing values (`stat_slabinterval()`).
Removed 896 rows containing missing values (`stat_slabinterval()`).

Warning: Removed 1012 rows containing missing values (`stat_slabinterval()`).

Warning: Removed 974 rows containing missing values (`stat_slabinterval()`).

Code

plot_MTDs_ann <- plot_MTDs |> annotate_figure(
  top = text_grob("Distribution of declared MTDs", 
  color = "black", face = "bold", size = 14)
)

plot_MTDs_ann

Informative stopping reasons & MTD allocation, Cycle 1

Code

preprocess_data_MTD_cycle1_info <- function(x) {
  x |> 
    count(model, x_label, stop_reason_cycle1) |>    
    group_by(model, x_label) |>
    mutate(percent = round(prop.table(n) * 100)) |>
    mutate(percent = ifelse(percent > 0, paste0(percent, "%"), ""))
}

cur_plot_cycle1_MTDs <- outcome_fig_informative |>
  preprocess_data_MTD_cycle1_info() |>
  ggplot(aes(x_label, y = n, fill = stop_reason_cycle1)) + 
  geom_bar(position = "fill", alpha = 0.8, stat = "identity") + 
  ylab("Relative frequencies") +
  xlab("Informative dropout?") + 
  scale_fill_manual(values = dosing_colors, drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  labs(fill='Stopping reason') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5)) +
    geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    )
  


plot_cycle1_MTDs_ann <- cur_plot_cycle1_MTDs |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: Informative censoring, cycle-1 MTDs",
      color = "black", face = "bold", size = 14
    )
  )

plot_cycle1_MTDs_ann

Informative stopping reasons & MTD allocation, Cumulative

Code

preprocess_data_MTD_cumulative_info <- function(x) {
  x |> 
    count(model, x_label, stop_reason_cumulative) |>    
    group_by(model, x_label) |>
    mutate(percent = round(prop.table(n) * 100)) |>
    mutate(percent = ifelse(percent > 0, paste0(percent, "%"), ""))
}

cur_plot_cumulative_MTDs_info <- outcome_fig_informative |>
  preprocess_data_MTD_cumulative_info() |>
  ggplot(aes(x_label, y = n, fill = stop_reason_cumulative)) + 
  geom_bar(position = "fill", alpha = 0.8, stat = "identity") + 
  ylab("Relative frequencies") +
  xlab("Informative dropout?") + 
  scale_fill_manual(values = dosing_colors, drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  labs(fill='Stopping reason') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5)) +
  geom_text(
      aes(label = percent),
      position = position_fill(vjust=0.5), 
      size = 3
    ) + 
  theme(legend.justification = "center", legend.position = "top")
  


plot_cumulative_MTDs_info_ann <- cur_plot_cumulative_MTDs_info |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: Informative censoring, cumulative MTDs",
      color = "black", face = "bold", size = 14
    )
  ) 



plot_cumulative_MTDs_info_ann

Code

ggsave(file.path(path.export, "MTD_cumulative_frequencies_info.png"), plot = plot_cumulative_MTDs_info_ann , width=20*1.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "MTD_cumulative_frequencies_info.pdf"), plot = plot_cumulative_MTDs_info_ann , width=20*1.5, height=10*1.2, units="cm")

Joint plot

Code

plotlist_both <- list(
    cur_plot_cycle1_MTDs + xlab("") + ylab("Relative frequencies, cycle-1") + guides(fill = guide_legend(nrow = 2)), 
    cur_plot_cumulative_MTDs_info + ggtitle("") + ylab("Relative frequencies, cumulative")
  )

plot_both_patients <- ggarrange(
  plotlist = plotlist_both,
  common.legend = T, ncol = 1, nrow = 2
)
plot_both_patients_ann_info <- plot_both_patients |>
  annotate_figure(
    top = text_grob(
      "Stopping reasons: relative frequencies, cycle-1 and cumulative MTDs",
      color = "black", face = "bold", size = 14
    )
  )

plot_both_patients_ann_info

Code

ggsave(file.path(path.export, "MTD_frequencies_info.pdf"), plot = plot_both_patients_ann_info , width=20, height=20, units="cm")

Informative patient allocation, Cycle-1

Code

res <- outcome_fig_informative |>
  select(
    model, x_label,
    num_patients_cycle1, 
    num_patients_overdose_cycle1,
    num_patients_target_cycle1,
    num_patients_underdose_cycle1
  ) |>
  group_by(model, x_label) |>
  summarize(
    prob_patients_overdose_cycle1  = sum(num_patients_overdose_cycle1)  / sum(num_patients_cycle1),
    prob_patients_target_cycle1    = sum(num_patients_target_cycle1)    / sum(num_patients_cycle1),
    prob_patients_underdose_cycle1 = sum(num_patients_underdose_cycle1) / sum(num_patients_cycle1)
  ) 

`summarise()` has grouped output by 'model'. You can override using the
`.groups` argument.

Code

res_long <- res |> 
  pivot_longer(
    cols = starts_with("prob_patients"), 
    names_transform = function(name) {
      name |>
        str_replace_all("prob_patients_", "") |> 
        str_replace_all("_cycle1", "")
    }
  ) |> 
  mutate(name = factor(name)) |>
  mutate(percent = ifelse(round(value * 100) > 0, paste0(round(value * 100), "%"), "")) 

cur_plot_cycle1_patients <- res_long |>
  ggplot(aes(x = x_label, y = value, fill = name)) + 
  # stat_slab(
  #   position = position_dodgejust(width = 0.8), 
  #   width = 0.8, 
  # ) +
  geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
  ylab(ifelse(length(p_cycle1_patients) == 0, "Relative frequencies", "")) +
  xlab("Informative dropout?") + 
  scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  labs(fill='Interval') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5)) +
  geom_text(
    aes(label = percent),
    position = position_fill(vjust=0.5),
    size = 3
  )

plot_cycle1_patients_ann <- cur_plot_cycle1_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients in cycle 1",
      color = "black", face = "bold", size = 14
    )
  )

plot_cycle1_patients_ann

Informative patient allocation, Cumulative

Code

p_cumulative_patients = list()

res <- outcome_fig_informative |>
  select( 
    model, x_label, 
    num_patients_cumulative, 
    num_patients_overdose_cumulative,
    num_patients_target_cumulative,
    num_patients_underdose_cumulative
  ) |>
  group_by(model, x_label) |>
  summarize(
    prob_patients_overdose_cumulative  = sum(num_patients_overdose_cumulative)  / sum(num_patients_cumulative),
    prob_patients_target_cumulative    = sum(num_patients_target_cumulative)    / sum(num_patients_cumulative),
    prob_patients_underdose_cumulative = sum(num_patients_underdose_cumulative) / sum(num_patients_cumulative)
  ) 

`summarise()` has grouped output by 'model'. You can override using the
`.groups` argument.

Code

res_long <- res |> 
  pivot_longer(
    cols = starts_with("prob_patients"), 
    names_transform = function(name) {
      name |>
        str_replace_all("prob_patients_", "") |> 
        str_replace_all("_cumulative", "")
    }
  ) |>
  mutate(name = factor(name)) |>
  mutate(percent = ifelse(round(value * 100) > 0, paste0(round(value * 100), "%"), "")) 
  

cur_plot_cumulative_patients <- res_long |>
  ggplot(aes(x = x_label, y = value, fill = name)) + 
  # stat_slab(
  #   position = position_dodgejust(width = 0.8), 
  #   width = 0.8, 
  # ) +
  geom_bar(position = "fill", alpha = 0.8, stat="identity") + 
  ylab(ifelse(length(p_cumulative_patients) == 0, "Relative frequencies", "")) +
  xlab("Informative dropout?") + 
  scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  labs(fill='Interval') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5)) +
  geom_text(
    aes(label = percent),
    position = position_fill(vjust=0.5),
    size = 3
  ) +   theme(legend.justification = "center", legend.position = "top")

plot_cumulative_patients_ann <- cur_plot_cumulative_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients over 3 cycles (cumulative)",
      color = "black", face = "bold", size = 14
    )
  )

plot_cumulative_patients_ann

Code

ggsave(file.path(path.export, "patient_cumulative_frequencies_info.png"), plot = plot_cumulative_patients_ann , width=20*1.5, height=10*1.2, units="cm")
ggsave(file.path(path.export, "patient_cumulative_frequencies_info.pdf"), plot = plot_cumulative_patients_ann , width=20*1.5, height=10*1.2, units="cm")

Joint plot

Code

plotlist_both <- list(
    cur_plot_cycle1_patients + xlab("") + ylab("Relative frequencies, cycle-1"), 
    cur_plot_cumulative_patients + ggtitle("") + ylab("Relative frequencies, cumulative")
  )

plot_both_patients <- ggarrange(
  plotlist = plotlist_both,
  common.legend = T, ncol = 1, nrow = 2
)
plot_both_patients_ann_info <- plot_both_patients |>
  annotate_figure(
    top = text_grob(
      "Probability of dosing patients",
      color = "black", face = "bold", size = 14
    )
  )

ggsave(file.path(path.export, "patient_frequencies_info.pdf"), plot = plot_both_patients_ann_info , width=20, height=20, units="cm")


plot_both_patients_ann_info

Trial length

Code

plot_trial_length_days_info <- outcome_fig_informative |>
  mutate(length_years = time_length(start_to_last_patient_cens_event_dt, "years")) |>
  ggplot(aes(x = x_label, y = length_years)) + 
  geom_boxplot( alpha = 0.5) +
  ylab(ifelse(length(p_trial_length_days) == 0, "Years", "")) +
  xlab("Dropout over 3 cycles") + 
    # scale_fill_manual(values=c("#F8766D", "lightgreen", "lightblue"), drop = FALSE) +
  facet_grid(. ~ model, scales = "free", space = "free_x")+
  #labs(fill='Interval') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5))
  
  # ggplot(aes(x_label, y = n, fill = stop_reason_cumulative)) + 
  # geom_bar(position = "fill", alpha = 0.8, stat = "identity") + 
  # ylab("Relative frequencies") +
  # xlab("Informative dropout?") + 
  # scale_fill_manual(values = dosing_colors, drop = FALSE) +
  # facet_grid(. ~ model, scales = "free", space = "free_x")+


plot_trial_length_days_info_ann <- plot_trial_length_days_info |>
  annotate_figure(
    top = text_grob(
      "Absolute trial lengths: Informative censoring",
      color = "black", face = "bold", size = 14
    )
  )


ggsave(file.path(path.export, "trial_lengths_info.png"), plot = plot_trial_length_days_info_ann , width=20, height=14, units="cm")

ggsave(file.path(path.export, "trial_lengths_info.pdf"), plot = plot_trial_length_days_info_ann , width=20, height=14, units="cm")

Code

plot_trial_length_days_info_ann